home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / modules.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  39KB  |  1,706 lines
  1. /* ******************************************************************** */
  2. /*  modules.c        copyright (c) codemist and university of bath 1989 */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modules.c,v 1.26 1992/05/28 11:26:40 pab Exp $
  9.  *
  10.  * $Log: modules.c,v $
  11.  * Revision 1.26  1992/05/28  11:26:40  pab
  12.  * not a lot
  13.  *
  14.  * Revision 1.25  1992/05/19  11:25:07  pab
  15.  * bindings exported with write permission, errors msgs improved
  16.  *
  17.  * Revision 1.24  1992/04/27  21:58:15  pab
  18.  * added more BCI dependency, plus corrected listify(c_fn)
  19.  *
  20.  * Revision 1.23  1992/04/26  20:55:02  pab
  21.  * fixes for interpreter
  22.  *
  23.  * Revision 1.22  1992/03/14  16:39:20  pab
  24.  * arg checking (again)
  25.  *
  26.  * Revision 1.21  1992/03/14  14:33:48  pab
  27.  * bytecode optional
  28.  *
  29.  * Revision 1.20  1992/03/07  21:45:16  pab
  30.  * apply changes
  31.  *
  32.  * Revision 1.19  1992/02/27  15:48:17  pab
  33.  * bytecode additions
  34.  *
  35.  * Revision 1.18  1992/02/10  12:06:20  pab
  36.  * new apply functions
  37.  *
  38.  * Revision 1.17  1992/02/02  16:33:47  pab
  39.  * improved backtrace output
  40.  *
  41.  * revision 1.12  1991/04/02  21:25:30  kjp
  42.  * compiler tidying.
  43.  *
  44.  * revision 1.11  1991/03/27  17:37:32  kjp
  45.  * fixed some definition ordering problems.
  46.  *
  47.  * revision 1.10  1991/03/14  14:14:14  fdla
  48.  * *** empty log message ***
  49.  *
  50.  * revision 1.9  1991/03/14  11:43:54  fdla
  51.  * c and elvira function switches expanded (20 args)
  52.  *
  53.  * revision 1.8  1991/03/13  16:57:34  kjp
  54.  * no change.
  55.  *
  56.  * revision 1.7  1991/02/19  18:53:04  kjp
  57.  * (expose spec*) in module body for reexportation.
  58.  *
  59.  * revision 1.6  1991/02/19  17:07:17  kjp
  60.  * updated for new module syntax with full streaming.
  61.  *
  62.  * revision 1.5  1991/02/13  18:24:17  kjp
  63.  * pass.
  64.  *
  65.  */
  66.  
  67. /*
  68.  * change log:
  69.  *   version 1, may 1989
  70.  *    major rewrite after talking to jap
  71.  *    added include function
  72.  *
  73.  *      threw it all away and did it again 'right' ! kjp (15/3/90)    
  74.  *    Did the same... pab (11/91)
  75.  */
  76. #define call_generic foo
  77.  
  78. #include "defs.h"
  79. #include "structs.h"
  80. #include "funcalls.h"
  81.  
  82. #include "error.h"
  83. #include "global.h"
  84.  
  85.  
  86. #include "allocate.h"
  87. #include "lists.h"
  88. #include "table.h"
  89. #include "modules.h"
  90. #include "toplevel.h"
  91. #include "symboot.h"
  92. #include "specials.h"
  93. #include "root.h"
  94. #include "class.h"
  95. #include "ngenerics.h"
  96. #include "calls.h"
  97. #include "bvf.h"
  98.  
  99. #undef call_generic
  100. /* elsewheres... */
  101. EUDECL(call_generic);
  102. /* in modules.h */
  103. EUDECL(Fn_module_value);
  104. static EUDECL(module_set_new_aux);
  105. EUDECL(register_module_import);
  106.  
  107. static LispObject sym_include_forms;
  108.  
  109. SYSTEM_GLOBAL(LispObject,current_interactive_module);
  110.  
  111. /* global module table --- needed for modops, etc*/
  112.  
  113. LispObject global_module_table;
  114.  
  115. /* hooking / unhooking */
  116.  
  117. LispObject put_module(LispObject *stacktop, LispObject name,LispObject module)
  118. {
  119.   if (global_module_table == NULL) {
  120.     fprintf(stderr,"initerror: NULL module table");
  121.     exit(1);
  122.   }
  123.   STACK_TMP(name);
  124.   EUCALL_3(tref_updator, global_module_table,name,module);
  125.   UNSTACK_TMP(name);
  126.   return(name);
  127. }
  128.  
  129. LispObject get_module(LispObject *stacktop, LispObject name)
  130. {
  131.   ARG_1(stacktop) = name;
  132.   ARG_0(stacktop) = global_module_table;
  133.   return(Fn_tref(stacktop));
  134. }
  135.  
  136. int module_loaded_p(LispObject* stacktop, LispObject name)
  137. {
  138.   return((get_module(stacktop, name) != nil));
  139. }
  140.  
  141. /* utilities !! */
  142.  
  143.  
  144. LispObject module_exports(LispObject mod)
  145. {
  146.   if (is_c_module(mod)) return(mod->C_MODULE.exported_names);
  147.   if (is_i_module(mod)) return(mod->I_MODULE.exported_names);
  148.  
  149.   CallError(NULL, "module exports: unknown module type",mod,NONCONTINUABLE);
  150.  
  151.   return(nil);
  152. }
  153.  
  154. void process_expose_form(LispObject *stacktop,LispObject mod,LispObject forms)
  155. {
  156.   static LispObject export_filter(LispObject *,LispObject,LispObject);
  157.   LispObject union_filter(LispObject *,LispObject,LispObject);
  158.   LispObject xx;
  159.  
  160.   STACK_TMP(mod);
  161.   xx=union_filter(stacktop,forms,mod);
  162.   UNSTACK_TMP(mod);
  163.   (void) export_filter(stacktop,xx,mod);
  164. }    
  165.       
  166. EUFUN_2( process_exports, mod, names)
  167. {
  168.  
  169.   if (is_c_module(mod))
  170.     CallError(stacktop,
  171.           "process exports: can't modify compiled module exports",
  172.           mod,NONCONTINUABLE);
  173.  
  174.   if (is_i_module(mod)) {
  175.     LispObject walker = names;
  176.  
  177.     if (names == nil) return nil;
  178.  
  179.     mod->I_MODULE.bounce_flag = TRUE;
  180.  
  181.     while (is_cons(walker)) {
  182.  
  183.       if (!is_symbol(CAR(walker))) {
  184.     STACK_TMP(walker);
  185.     EUCALL_2(process_top_level_form,ARG_1(stackbase)/*mod*/,CAR(walker)); 
  186.     UNSTACK_TMP(walker);
  187.       }
  188.       walker = CDR(walker);
  189.     }
  190.  
  191.     mod = ARG_0(stackbase);
  192.     mod->I_MODULE.bounce_flag = FALSE;
  193.  
  194.     /* all valid exports */
  195.  
  196.     walker = ARG_1(stackbase);
  197.  
  198.     while(is_cons(walker)) {
  199.       if (is_symbol(CAR(walker))) {
  200.     LispObject xx;
  201.     STACK_TMP(walker);
  202.     EUCALLSET_2(xx, Fn_memq,CAR(walker),mod->I_MODULE.exported_names);
  203.     UNSTACK_TMP(walker);
  204.     if (xx == nil) {
  205.       LispObject xx;
  206.       mod = ARG_0(stackbase);
  207.       STACK_TMP(walker);
  208.       EUCALLSET_2(xx, Fn_cons, CAR(walker),mod->I_MODULE.exported_names);
  209.       mod = ARG_0(stackbase);
  210.       mod->I_MODULE.exported_names = xx;
  211.       UNSTACK_TMP(walker);
  212.     }
  213.       }
  214.  
  215.       walker = CDR(walker);
  216.     }
  217.  
  218.     return nil;
  219.   }
  220.  
  221.   CallError(stacktop, "process exports: non-module arg",mod,NONCONTINUABLE);
  222. }
  223. EUFUN_CLOSE
  224.  
  225. EUFUN_2( process_included_forms, mod, forms)
  226. {
  227.   extern LispObject Fn_close(LispObject*);
  228.  
  229.   LispObject path,stream,read;
  230.   FILE *cstream;
  231.  
  232.   if (!is_cons(forms))
  233.     CallError(stacktop, "inlude-forms: missing path",forms,NONCONTINUABLE);
  234.  
  235.   if (!is_string((path = CAR(forms))))
  236.     CallError(stacktop, "include-forms: bad path",path,NONCONTINUABLE);
  237.  
  238.   cstream = fopen(stringof(path),"r");
  239.   if (cstream == NULL)
  240.     CallError(stacktop, "include-forms: can't open file",path,NONCONTINUABLE);
  241.  
  242.   stream = (LispObject) allocate_stream(stacktop, cstream,'r');
  243.  
  244.   fprintf(StdOut->STREAM.handle,"including \'%s\'\n",stringof(path));
  245.  
  246.   while (1) {
  247.     STACK_TMP(stream);
  248.     EUCALLSET_1(read, Fn_read, stream);
  249.     UNSTACK_TMP(stream);
  250.     if (read == q_eof) break;
  251.     STACK_TMP(stream);
  252.     EUCALLSET_2(read,process_top_level_form,ARG_0(stackbase),read);
  253.     UNSTACK_TMP(stream);
  254.   }
  255.  
  256.   EUCALL_1(Fn_close, stream);
  257.  
  258.   fprintf(StdOut->STREAM.handle,"included \'%s\'\n",stringof(path));
  259.  
  260. }
  261. EUFUN_CLOSE
  262.  
  263. static LispObject sym_only;
  264. static LispObject sym_except;
  265.  
  266. static LispObject module_addresses(LispObject *stacktop, LispObject mod)
  267. {
  268.   LispObject exports,addresses;
  269.  
  270.   addresses = nil;
  271.   exports = mod->I_MODULE.exported_names;
  272.  
  273.   
  274.   while (is_cons(exports)) {
  275.     LispObject name, xx;
  276.     STACK_TMP(CDR(exports));
  277.     STACK_TMP(mod);
  278.     STACK_TMP(addresses);
  279.  
  280.     name = CAR(exports);
  281.     
  282.     EUCALLSET_2(xx, Fn_cons, name, mod); /* canonical address */
  283.     EUCALLSET_2(name,Fn_cons, CAR(xx)/*name*/, xx);
  284.     UNSTACK_TMP(addresses);
  285.     EUCALLSET_2(addresses, Fn_cons,name, addresses);
  286.     UNSTACK_TMP(mod);
  287.     UNSTACK_TMP(exports);
  288.   }
  289.  
  290.  
  291.   return(addresses);
  292. }
  293.  
  294. /* filters */
  295.  
  296. static LispObject only_filter(LispObject *stacktop,
  297.                   LispObject names,LispObject addresses)
  298. {
  299.   LispObject remains;
  300.  
  301.   remains = nil;
  302.  
  303.   while (is_cons(addresses)) {
  304.  
  305.     STACK_TMP(addresses);
  306.     STACK_TMP(remains);
  307.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) != nil) {
  308.       UNSTACK_TMP(remains);
  309.       STACK_TMP(names);
  310.       EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  311.       UNSTACK_TMP(names);
  312.     }
  313.     else UNSTACK_TMP(remains);
  314.  
  315.     UNSTACK_TMP(addresses);
  316.     addresses = CDR(addresses);
  317.  
  318.   }
  319.  
  320.   return(remains);
  321. }
  322.  
  323. static LispObject except_filter(LispObject *stacktop,
  324.                 LispObject names,LispObject addresses)
  325. {
  326.   LispObject remains;
  327.  
  328.   remains = nil;
  329.  
  330.   while (is_cons(addresses)) {
  331.  
  332.     STACK_TMP(addresses);
  333.  
  334.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) == nil) 
  335.       {
  336.     STACK_TMP(names);
  337.     EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  338.     UNSTACK_TMP(names);
  339.       }
  340.  
  341.     UNSTACK_TMP(addresses);
  342.  
  343.     addresses = CDR(addresses);
  344.  
  345.   }
  346.  
  347.   return(remains);
  348. }
  349.  
  350. static LispObject name_list_pair(LispObject *stacktop,
  351.                  LispObject k,LispObject l)
  352. {
  353.   while (is_cons(l)) {
  354.  
  355.     if (!is_cons(CAR(l)))
  356.       CallError(stacktop,
  357.         "module importation: bad rename names",l,NONCONTINUABLE);
  358.  
  359.     if (k == CAR(CAR(l))) 
  360.       return(CAR(l));
  361.     else
  362.       l = CDR(l);
  363.   }
  364.  
  365.   return(nil);
  366. }
  367.  
  368. static LispObject rename_filter(LispObject *stacktop,
  369.                 LispObject pairs,LispObject addresses)
  370. {
  371.   LispObject walker;
  372.  
  373.   walker = addresses;
  374.  
  375.   while (is_cons(walker)) {
  376.     LispObject pair;
  377.     STACK_TMP(walker);
  378.     pair = name_list_pair(stacktop,CAR(CAR(walker)),pairs);
  379.     UNSTACK_TMP(walker);
  380.     if (pair != nil) { /* to be renamed... */
  381.  
  382.       CAR(CAR(walker)) = CAR(CDR(pair));
  383.  
  384.     }
  385.  
  386.     walker = CDR(walker);
  387.   }
  388.   
  389.   return(addresses);
  390. }
  391.  
  392. LispObject
  393.   union_filter(LispObject *stacktop, LispObject list,LispObject context)
  394. {
  395.   static LispObject filter_import_thang(LispObject*,LispObject,LispObject);
  396.   LispObject all;
  397.  
  398.   all = nil;
  399.  
  400.   while (is_cons(list)) {
  401.     LispObject xx;
  402.  
  403.     STACK_TMP(CDR(list));
  404.     STACK_TMP(context);
  405.     STACK_TMP(all);
  406.     xx = filter_import_thang(stacktop,CAR(list),context);
  407.     UNSTACK_TMP(all);
  408.     EUCALLSET_2(all, Fn_nconc, xx,all);
  409.     UNSTACK_TMP(context);
  410.  
  411.     UNSTACK_TMP(list);
  412.  
  413.   }
  414.  
  415.   return(all);
  416. }
  417.  
  418. static LispObject export_filter(LispObject *stacktop,
  419.                 LispObject ads,LispObject mod)
  420. {
  421.   LispObject walker;
  422.   
  423.   STACK_TMP(ads);
  424.   walker = ads;
  425.  
  426.   while (is_cons(walker)) {
  427.     LispObject name;
  428.  
  429.     name = CAR(CAR(walker)); 
  430.  
  431.     STACK_TMP(CDR(walker));
  432.  
  433.     STACK_TMP(mod);
  434.     STACK_TMP(name);
  435.     if (EUCALL_2(Fn_memq,name,mod->I_MODULE.exported_names) == nil)
  436.       {
  437.     LispObject xx;
  438.     UNSTACK_TMP(name);
  439.     EUCALLSET_2(xx, Fn_cons,name,mod->I_MODULE.exported_names);
  440.     UNSTACK_TMP(mod);
  441.     mod->I_MODULE.exported_names = xx;
  442.       }
  443.     else 
  444.       { UNSTACK_TMP(name);    
  445.     UNSTACK_TMP(mod);
  446.       }
  447.     UNSTACK_TMP(walker);
  448.  
  449.   }
  450.  
  451.   UNSTACK_TMP(ads);
  452.   return(ads);
  453. }
  454.  
  455. static void register_filtered_addresses(LispObject *stacktop,
  456.                     LispObject ads,LispObject mod)
  457. {
  458.   while (is_cons(ads)) {
  459.     LispObject first;
  460.     
  461.     first = CAR(ads); ads = CDR(ads);
  462.     STACK_TMP(mod);
  463.     STACK_TMP(ads);
  464.     EUCALL_4(register_module_import,mod,
  465.          CAR(first),CDR(CDR(first)),
  466.          CAR(CDR(first)));
  467.     UNSTACK_TMP(ads);
  468.     UNSTACK_TMP(mod);
  469.   }
  470. }
  471.     
  472. static LispObject filter_import_thang(
  473.               LispObject* stacktop, LispObject spec,LispObject context)
  474. {
  475.   LispObject op,xx;
  476.  
  477.   if (is_symbol(spec)) {
  478.     STACK_TMP(spec);
  479.     EUCALL_1(load_module,spec);
  480.     UNSTACK_TMP(spec);
  481.     xx= get_module(stacktop,spec);
  482.     return(module_addresses(stacktop,xx));
  483.   }
  484.  
  485.   if (!is_cons(spec)) 
  486.     CallError(stacktop, "module importation: invalid import spec",spec,NONCONTINUABLE);
  487.  
  488.   op = CAR(spec); spec = CDR(spec);
  489.  
  490.   if (op == sym_only) {
  491.     
  492.     if (!is_cons(spec))
  493.       CallError(stacktop, "module importation: bad only form",spec,NONCONTINUABLE);
  494.     
  495.     STACK_TMP(CAR(spec));
  496.     xx=union_filter(stacktop, CDR(spec),context);
  497.     UNSTACK_TMP(spec);
  498.     return(only_filter(stacktop,spec,xx));
  499.  
  500.   }
  501.  
  502.   if (op == sym_except) {
  503.  
  504.     if (!is_cons(spec))
  505.       CallError(stacktop, "module importation: bad except form",spec,NONCONTINUABLE);
  506.     STACK_TMP(CAR(spec));
  507.     xx=union_filter(stacktop, CDR(spec),context);
  508.     UNSTACK_TMP(spec);
  509.     return(except_filter(stacktop,spec,xx));
  510.  
  511.   }
  512.  
  513.   if (op == sym_rename) {
  514.  
  515.     if (!is_cons(spec))
  516.       CallError(stacktop, "module importation: bad rename form",spec,NONCONTINUABLE);
  517.     STACK_TMP(CAR(spec));
  518.     xx= union_filter(stacktop, CDR(spec),context);
  519.     UNSTACK_TMP(spec);
  520.     return(rename_filter(stacktop,spec,xx));
  521.  
  522.   }
  523.  
  524.   if (op == sym_export) {
  525.     STACK_TMP(spec); STACK_TMP(context);
  526.     xx=union_filter(stacktop, spec,context);
  527.     UNSTACK_TMP(context); UNSTACK_TMP(spec);
  528.     return(export_filter(stacktop,xx,context));
  529.  
  530.   }
  531.  
  532.   CallError(stacktop, "module importation: invalid import operation",op,NONCONTINUABLE);
  533.  
  534.   return(nil);
  535. }
  536.  
  537. void process_import_form(LispObject *stackbase,LispObject mod,LispObject spec)
  538. {
  539.   LispObject *stacktop=stackbase+1;
  540.   
  541.   ARG_0(stackbase)=mod;
  542.  
  543.   if (!is_cons(spec))
  544.     CallError(stacktop,
  545.           "import: invalid NULL import spec",spec,NONCONTINUABLE);
  546.  
  547.   while (is_cons(spec)) {
  548.     LispObject name = CAR(spec);
  549.     STACK_TMP(CDR(spec));
  550.  
  551.     if (is_symbol(name)) {
  552.       LispObject inmod,exports;
  553.       
  554.       STACK_TMP(name);
  555.       EUCALL_1(load_module,name);
  556.       UNSTACK_TMP(name);
  557.  
  558.       inmod = get_module(stacktop,name);
  559.       mod=ARG_0(stackbase);
  560.       exports = module_exports(inmod);
  561.  
  562.       while (exports != nil) {
  563.     STACK_TMP(mod);
  564.     STACK_TMP(inmod);
  565.     STACK_TMP(CDR(exports));
  566.     EUCALL_4(register_module_import,ARG_0(stackbase)/*mod*/,
  567.          CAR(exports),inmod,CAR(exports));
  568.     UNSTACK_TMP(exports);
  569.     UNSTACK_TMP(inmod);
  570.     UNSTACK_TMP(mod);
  571.       }
  572.  
  573.     }
  574.     else {
  575.       
  576.       CallError(stacktop,
  577.         "import: non-symbolic module name",spec,NONCONTINUABLE);
  578.  
  579.     }
  580.  
  581.     UNSTACK_TMP(spec);
  582.  
  583.   }
  584.  
  585. }
  586.  
  587. void process_import_spec(LispObject *stacktop, LispObject mod,LispObject spec)
  588. {
  589.   LispObject xx;
  590.   STACK_TMP(mod);
  591.   xx=union_filter(stacktop, spec,mod);
  592.   UNSTACK_TMP(mod);
  593.   register_filtered_addresses(stacktop,xx,mod);
  594. }
  595.  
  596.  
  597. EUFUN_2(process_top_level_form, mod, form)
  598. {
  599.   LispObject op;
  600.  
  601.   /* ok, so here's the game plan -
  602.    
  603.    * for each form, check out the car.
  604.    * if it's not a symbol - crash, probably, for the moment...
  605.    * a symbol means check out any imported macros...
  606.    *   no macros means check out special form key words...
  607.    *     none of them means error.
  608.    * expand macros once and try again.
  609.    * for matching keywords, do the bizness
  610.  
  611.    */
  612.  
  613.  top:
  614.   /* interactive hack */
  615.  
  616.   if (!is_cons(form)) RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  617.  
  618.   op = CAR(form); 
  619.  
  620.   if (is_symbol(op)) {
  621.  
  622.     /* really just check for defining forms and 'progn' */
  623.  
  624.     if (op == sym_progn) {
  625.       LispObject walker,ans = nil;
  626.       walker = form;
  627.  
  628.       walker = CDR(walker);
  629.       while (is_cons(walker)) {
  630.     STACK_TMP(CDR(walker));
  631.     mod = ARG_0(stackbase);
  632.     EUCALLSET_2(ans, process_top_level_form,mod,CAR(walker));
  633.     UNSTACK_TMP(walker);
  634.       }
  635.  
  636.       return(ans);
  637.     }
  638.  
  639.     /*
  640.     if (op == sym_define) {
  641.       return(TL_define(stacktop,mod,CDR(form)));
  642.     }
  643.     */
  644.     if (op == sym_defun)       {
  645.       return(TL_defun(stacktop,mod,CDR(form)));
  646.     }
  647.     if (op == sym_deflocal) {
  648.       return(TL_deflex(stacktop,mod,CDR(form)));
  649.     }
  650.     if (op == sym_defmacro) {
  651.       return(TL_defmacro(stacktop,mod,CDR(form)));
  652.     }
  653.  
  654.     if (op == sym_defvar) return(TL_defvar(stacktop,mod,CDR(form)));
  655.       
  656.     if (op == sym_defconstant) return(TL_defconstant(stacktop,mod,CDR(form))); 
  657.  
  658.     if (op == sym_import) {
  659.       process_import_form(stacktop,mod,CDR(form));
  660.       return(nil);
  661.     }
  662.  
  663.     if (op == sym_expose) {
  664.       process_expose_form(stacktop,mod,CDR(form)); 
  665.       return(nil);
  666.     }
  667.  
  668.     if (op == sym_export) {
  669.       EUCALL_2(process_exports,mod,CDR(form));
  670.       return(nil);
  671.     }
  672.  
  673.     if (op == sym_include_forms) {
  674.       EUCALL_2(process_included_forms,mod,CDR(form));
  675.       return(nil);
  676.     }
  677.  
  678.     /* hell, that'll do for now */
  679.  
  680.     /* try a macroexpand... */
  681.  
  682.     EUCALLSET_2(form,macroexpand_1,mod,form);
  683.     
  684.     if (CAR(CDR(form)) != nil) {
  685.       while (CAR(CDR(form))!=nil)
  686.     { form = CAR(form);
  687.       mod=ARG_0(stackbase);
  688.       EUCALLSET_2(form, macroexpand_1,mod,form);
  689.     }
  690.       
  691.       form = CAR(form);
  692.       
  693.       mod=ARG_0(stackbase);
  694.       goto top;
  695.     }
  696.  
  697.     form = CAR(form);
  698.  
  699.     /* not a macro... */
  700.  
  701.     /* ok, so for user-friendliness (ho-ho) just to a module eval */
  702.  
  703.     mod=ARG_0(stackbase);
  704.     RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  705.   }
  706.  
  707.   /* wasne a symbol - rather than crash, try eval first */
  708.  
  709.   {
  710.     LispObject ans;
  711.  
  712.     EUCALLSET_3(ans,module_eval,mod,NULL,form);
  713.     return(ans);
  714.   }
  715. }
  716. EUFUN_CLOSE
  717.  
  718. /* biggie!! */
  719.  
  720. LispObject backtrace_handle;
  721. LispObject list_backtrace;
  722.  
  723. #define PUSH_TRACE(fun,args) \
  724.   { \
  725.     STACK_TMP(args); STACK_TMP(fun); STACK_TMP(backtrace_handle); \
  726.   }
  727.  
  728. #define SET_TRACE(sp,op,env)    \
  729. {                \
  730.    *(sp)=env;            \
  731.    *((sp)+1)=op;            \
  732.    *((sp)+2)=backtrace_handle;    \
  733. }
  734.  
  735. void quickie_module_eval_backtrace(LispObject *stacktop)
  736. {
  737.   LispObject *walker;
  738.  
  739.   fprintf(StdOut->STREAM.handle,"\n");
  740.  
  741.   for (walker = GC_STACK_BASE(); walker != GC_STACK_POINTER(); ++walker) {
  742.     
  743.     if ((*(walker)) == backtrace_handle) {
  744.       
  745.       fprintf(StdOut->STREAM.handle,"entered: ");
  746.       EUCALL_2(Fn_print, ((*(walker-1)))->FUNCTION.name,StdOut);
  747.  
  748.     }
  749.  
  750.   }
  751.  
  752.   fprintf(StdOut->STREAM.handle,"\n");
  753.  
  754. }
  755.  
  756. void module_eval_backtrace(LispObject *stacktop)
  757. {
  758.   LispObject *walker;
  759.   Env env;
  760.  
  761.   for (walker = GC_STACK_BASE(); walker != stacktop; ++walker) {
  762.     
  763.     if (*walker == backtrace_handle) {
  764.       
  765.       fprintf(StdOut->STREAM.handle,"\n");
  766.       fprintf(StdOut->STREAM.handle,"entered: ");
  767.       EUCALL_2(Fn_print,((*(walker-1)))->FUNCTION.name,StdOut);
  768.       fprintf(StdOut->STREAM.handle,"\n");
  769.  
  770.       if ((*(walker-2)) != NULL && typeof((*(walker-2))) == TYPE_ENV) {
  771.  
  772.     for (env = (Env) (*(walker-2)); env != NULL; env = env->next) {
  773.  
  774.       fprintf(StdOut->STREAM.handle,"  ");
  775.       STACK_TMPV(env);
  776.       EUCALL_2(Fn_prin,env->variable,StdOut);
  777.       UNSTACK_TMPV(env);
  778.       STACK_TMPV(env);
  779.       fprintf(StdOut->STREAM.handle,": ");
  780.       EUCALL_2(Gf_generic_prin,env->value,StdOut);
  781.       fprintf(StdOut->STREAM.handle,"\n");
  782.       UNSTACK_TMPV(env);
  783.     }
  784.  
  785.       }
  786.  
  787.     }
  788.  
  789.   }
  790.  
  791.   fprintf(StdOut->STREAM.handle,"\n");
  792.  
  793. }
  794.  
  795. /*
  796.   *
  797.   * The interpreter lies below 
  798.   */
  799.  
  800. #define check_if(stmt) /* :-> */
  801.  
  802. LispObject module_eval(LispObject *stackbase)
  803. {
  804.   LispObject op;
  805.   LispObject mod,env,form;
  806.   LispObject *stacktop;
  807.  
  808.   mod = ARG_0(stackbase);
  809.   env = ARG_1(stackbase);
  810.   form = ARG_2(stackbase);
  811.   (void) system_stacks_ok_p(stackbase,form); 
  812.   
  813.  
  814.   stackbase+=3;    /* Room for trace */
  815.   ARG_0(stackbase)=mod;
  816.   ARG_1(stackbase)=env;
  817.   ARG_2(stackbase)=form;
  818.  toplabel:  
  819.   mod = ARG_0(stackbase);
  820.   env = ARG_1(stackbase);
  821.   form = ARG_2(stackbase);
  822.  
  823.   stacktop=stackbase+3;
  824.  
  825.   if (!is_cons(form))
  826.     { /* should check for loose special forms */
  827.       if (is_symbol(form))
  828.     {
  829.       LispObject tmp=symbol_ref(stacktop,mod,env,form);
  830.       if (!is_special(tmp)) return(tmp);
  831.       else    
  832.         CallError(stacktop,"Invalid use of reservered word",form,NONCONTINUABLE);
  833.     }
  834.       else    
  835.     return form;
  836.     }
  837.  
  838.   op = CAR(form);
  839.  
  840.   ARG_3(stackbase)=op;
  841.   stacktop++;
  842.  
  843.   if (is_symbol(op))
  844.     { 
  845. #ifndef NODEBUG
  846.       { extern int gc_paranoia;
  847.     if (gc_paranoia)
  848.       fprintf(stderr,"%s\n",stringof(op->SYMBOL.pname));
  849.       }
  850. #endif
  851.       op = symbol_ref(stacktop,mod,(LispObject)env,op);
  852.       ARG_3(stackbase)=op;
  853.     }
  854.   else
  855.     if (is_cons(op))
  856.       {    
  857.     op=EUCALL_3(module_eval,mod,env,op);
  858.     ARG_3(stackbase)=op;
  859.     mod=ARG_0(stackbase);
  860.     env=ARG_1(stackbase);
  861.     form=ARG_2(stackbase);
  862.       }
  863.  
  864.   if (is_macro(op))
  865.     { LispObject newform;
  866.       newform = EUCALL_2(module_mv_apply_1,op,CDR(form));
  867.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,newform);
  868.     }
  869.  
  870.  
  871.   if (is_c_function(op) || is_c_macro(op) 
  872. #ifdef BCI
  873.       || is_b_function(op) || is_b_macro(op)
  874. #endif
  875.       )
  876.     {
  877.       LispObject lastarg;
  878.  
  879.       LispObject walker, extras = nil;
  880.       int i, args, extra;
  881.       BEGIN_NARY_EUCALL();
  882.  
  883.       walker = CDR(form);
  884. #ifdef BCI
  885.       args = ((is_c_function(op)||is_c_macro(op))
  886.           ? op->C_FUNCTION.argtype
  887.           : intval(bytefunction_nargs(op)));
  888. #else
  889.       args = op->C_FUNCTION.argtype;
  890. #endif
  891.       extra = (args < 0);
  892.       args = extra ? -args : args;
  893.       
  894.       if (is_c_function(op) || is_c_macro(op))
  895.     if (op->C_FUNCTION.env != NULL)
  896.       { STACK_TMP(nil); /* space for arg */
  897.         NARY_PUSH_ARG((LispObject)op->C_FUNCTION.env);
  898.       }
  899.  
  900.       if (args==0)
  901.     {
  902.       if (walker!=nil)
  903.         CallError(stacktop,"Too many args to C-fn",op,NONCONTINUABLE);
  904.       else
  905.         {
  906. #ifdef BCI        
  907.           if (is_b_function(op)||is_b_macro(op))
  908.         {
  909.           return(apply_nary_bytefunction(stackbase,0,op));
  910.         }    
  911.           else
  912.         return(op->C_FUNCTION.func(stackbase));
  913. #else
  914.           return(op->C_FUNCTION.func(stackbase));
  915. #endif
  916.         }
  917.     }
  918.       for (i=0; i < args-1 ; i++)
  919.     {
  920.       STACK_TMP(nil); /* place where arg will go */
  921.       STACK_TMP(CDR(walker));
  922.       /* XXX assume 1) CDR(nil)=nil, module_eval(nil)=nil */
  923.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,
  924.                  ARG_1(stackbase)/* env */,CAR(walker)));
  925.       UNSTACK_TMP(walker);
  926.     }
  927.  
  928.       if (extra)
  929.     { 
  930.       LispObject ptr;
  931.  
  932.       if (walker!=nil)
  933.         {
  934.           LispObject xx;
  935.  
  936.           STACK_TMP(CDR(walker));
  937.           EUCALLSET_3(xx,module_eval,ARG_0(stackbase) /*mod*/,
  938.                               ARG_1(stackbase)/*env*/, CAR(walker));
  939.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  940.           UNSTACK_TMP(walker);
  941.           STACK_TMP(lastarg);
  942.           ptr = lastarg;
  943.           while(walker!=nil)
  944.         {    
  945.           STACK_TMP(CDR(walker));
  946.           STACK_TMP(ptr);
  947.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)    /*mod*/, 
  948.                   ARG_1(stackbase)/*env*/, CAR(walker));
  949.           xx = EUCALL_2(Fn_cons, xx, nil);
  950.           UNSTACK_TMP(ptr);
  951.           CDR(ptr)=xx;
  952.           ptr = CDR(ptr);
  953.           UNSTACK_TMP(walker);
  954.         }
  955.           UNSTACK_TMP(lastarg);
  956.         }
  957.       else
  958.         lastarg=nil;
  959.     }
  960.       else
  961.     {
  962.       if (walker == nil)
  963.         {
  964.           CallError(stacktop,
  965.             "C function wants more args", op, NONCONTINUABLE);
  966.         }
  967.  
  968.       if (CDR(walker)!=nil)
  969.         CallError(stacktop,"Eval: Too many args to 'C-function",CDR(walker),
  970.               NONCONTINUABLE);
  971.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase)/*mod*/,
  972.               ARG_1(stackbase)/*env*/,CAR(walker));
  973.     }
  974.       NARY_PUSH_ARG(lastarg);
  975.       op=ARG_3(stackbase);
  976.  
  977. #ifdef BCI
  978.       if (is_c_function(op)||is_c_macro(op))
  979.     return(NARY_EUCALL(op->C_FUNCTION.func));
  980.       else
  981.     {    /* B-function */
  982.       return(apply_nary_bytefunction(argbase,args,op));
  983.     }
  984. #else
  985.       return(NARY_EUCALL(op->C_FUNCTION.func));
  986. #endif
  987.       END_NARY_EUCALL();
  988.     }
  989.  
  990.   if (is_generic(op))
  991.     { 
  992.       RETURN_EUCALL(EUCALL_4(call_generic,mod,env,op,CDR(form)));
  993.     }
  994.  
  995.  
  996.   if (is_i_function(op)
  997.       || is_i_macro(op))
  998.     {
  999.       LispObject args, exps, callenv;
  1000.       int extra;
  1001.  
  1002.       extra = ( op->I_FUNCTION.argtype < 0);
  1003.       callenv = (LispObject) op->I_FUNCTION.env;
  1004.       STACK_TMP(op);
  1005.       if (op->I_FUNCTION.argtype == 0)
  1006.     {
  1007.       if (CDR(form)!=nil)
  1008.         CallError(stackbase,"Too many args to I-function",op,NONCONTINUABLE);
  1009.     }
  1010.       else
  1011.     {    
  1012.       for ((args = op->I_FUNCTION.bvl,
  1013.         exps = CDR(form));
  1014.            is_cons(args);
  1015.            (args = CDR(args),
  1016.         exps = CDR(exps)))
  1017.         {
  1018.           if (exps == nil)
  1019.         {
  1020.           CallError(stacktop,
  1021.                 "i function wants more args", op, NONCONTINUABLE);
  1022.         }
  1023.           else
  1024.         {
  1025.           LispObject nextarg;
  1026.  
  1027.           STACK_TMP(exps);
  1028.           STACK_TMP(args);
  1029.           STACK_TMP(callenv);
  1030.           EUCALLSET_3(nextarg,module_eval,
  1031.                   ARG_0(stackbase) /*mod*/,
  1032.                   ARG_1(stackbase) /*env*/,
  1033.                   CAR(exps));
  1034.           UNSTACK_TMP(callenv);
  1035.           UNSTACK_TMP(args);
  1036.           STACK_TMP(args);
  1037.           callenv = allocate_env(stacktop,CAR(args),
  1038.                      nextarg, callenv);
  1039.           UNSTACK_TMP(args);
  1040.           UNSTACK_TMP(exps);
  1041.  
  1042.         }
  1043.           /* end i-function-loop */
  1044.         }
  1045.                           
  1046.       /* last arg */
  1047.  
  1048.       if (extra)
  1049.         {
  1050.           LispObject lastarg=nil;
  1051.  
  1052.           STACK_TMP(callenv); /* need this */
  1053.           STACK_TMP(args);
  1054.  
  1055.           if (exps!=nil)
  1056.         {
  1057.           LispObject xx;
  1058.           LispObject ptr;
  1059.  
  1060.           STACK_TMP(CDR(exps));
  1061.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1062.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1063.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1064.           UNSTACK_TMP(exps);
  1065.           STACK_TMP(lastarg);
  1066.           ptr = lastarg;
  1067.           while(exps!=nil)
  1068.             {    
  1069.               STACK_TMP(CDR(exps));
  1070.               STACK_TMP(ptr);
  1071.               EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1072.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1073.               xx = EUCALL_2(Fn_cons, xx, nil);
  1074.               UNSTACK_TMP(ptr);
  1075.               CDR(ptr)=xx;
  1076.               ptr = CDR(ptr);
  1077.               UNSTACK_TMP(exps);
  1078.             }
  1079.           UNSTACK_TMP(lastarg);
  1080.         }
  1081.           else
  1082.         lastarg=nil;
  1083.  
  1084.           UNSTACK_TMP(args);
  1085.           UNSTACK_TMP(callenv);
  1086.           callenv = allocate_env(stacktop,args,lastarg, callenv);
  1087.         }
  1088.       else if (exps!=nil)
  1089.         {    
  1090.           UNSTACK_TMP(op);
  1091.           CallError(stackbase,"Too many args to i-function",op,NONCONTINUABLE);
  1092.         }
  1093.     }
  1094.  
  1095.       UNSTACK_TMP(op);
  1096.       /* now we call it.., cunningly inlining the progn */
  1097.  
  1098.       { LispObject forms = op->I_FUNCTION.body;
  1099.     /* Throw it all away */
  1100.     stacktop=stackbase;
  1101.     SET_TRACE(stackbase-3,op,callenv);
  1102.  
  1103.     while (CDR(forms)!=nil)
  1104.       {
  1105.         STACK_TMP(CDR(forms));
  1106.         STACK_TMP(callenv);
  1107.         STACK_TMP(op);
  1108.         EUCALL_3(module_eval,
  1109.              op->I_FUNCTION.home,
  1110.              callenv,
  1111.              CAR(forms));
  1112.         UNSTACK_TMP(op);
  1113.         UNSTACK_TMP(callenv);
  1114.         UNSTACK_TMP(forms);
  1115.       }
  1116.  
  1117.     mod = ARG_0(stackbase) = op->I_FUNCTION.home;
  1118.     env = ARG_1(stackbase) = callenv;
  1119.     form = ARG_2(stackbase) = CAR(forms);
  1120.     goto toplabel;
  1121.       }
  1122.     }
  1123.   
  1124.   if (is_special(op))
  1125.     {
  1126.       if (op==special_progn)
  1127.     { LispObject forms = CDR(form);
  1128.     
  1129.       while (CDR(forms)!=nil)
  1130.         {
  1131.           STACK_TMP(CDR(forms));
  1132.           EUCALL_3(module_eval,
  1133.                ARG_0(stackbase)/*mod*/,
  1134.                ARG_1(stackbase)/*env*/,
  1135.                CAR(forms));
  1136.           UNSTACK_TMP(forms);
  1137.         }
  1138.  
  1139.       EUTAIL_3(ARG_0(stackbase)/*mod*/,
  1140.            ARG_1(stackbase)/*env*/,
  1141.            CAR(forms));
  1142.     }
  1143.       if (op == special_if)
  1144.     {    
  1145.       LispObject res,stmt=CDR(form);
  1146.       check_if(stmt);
  1147.       
  1148.       STACK_TMP(CDR(stmt));
  1149.       res = EUCALL_3(module_eval,mod,env,CAR(stmt));
  1150.       if ( res == nil)
  1151.         {
  1152.           UNSTACK_TMP(stmt);
  1153.           EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/
  1154.                ,CAR(CDR(stmt)));
  1155.         }
  1156.       UNSTACK_TMP(stmt);
  1157.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(stmt));
  1158.     }
  1159.  
  1160.       if (op->SPECIAL.env==NULL)
  1161.     RETURN_EUCALL(EUCALL_3(op->SPECIAL.func,mod,env,CDR(form)));
  1162.       else
  1163.     RETURN_EUCALL(EUCALL_2(op->SPECIAL.func,mod,CDR(form)));
  1164.     }
  1165.  
  1166.   if (is_continue(op))
  1167.     { LispObject res;
  1168.       
  1169.       res = EUCALL_3(module_eval,mod,env,CAR(CDR(form)));
  1170.       op=ARG_3(stackbase);
  1171.       call_continuation(stacktop,op,res);
  1172.       return nil; /* not really */
  1173.     }
  1174.  
  1175.  
  1176.  
  1177.   fprintf(stderr,"{?: 0x%x}",op);
  1178.   CallError(stacktop, "Unknown operator thing",op,NONCONTINUABLE);
  1179.   return nil; /* not ever */
  1180. }
  1181.  
  1182.  
  1183.  
  1184. /* The same, but different... we could be clever + do the tail call properly*/
  1185. EUFUN_4( call_generic, mod, env, gf, forms)
  1186. {
  1187.   LispObject lastarg;
  1188.   LispObject walker, extras = nil;
  1189.   int i, args, extra;
  1190.   BEGIN_NARY_EUCALL();
  1191.  
  1192.   walker = forms;
  1193.   args = intval(generic_argtype(gf));
  1194.   extra = (args < 0);
  1195.   args = extra ? -args : args;
  1196.  
  1197.   /* Too much cut and paste! */
  1198.   for (i=0; i < args-1 ; i++)
  1199.     {
  1200.       STACK_TMP(nil);        /* place where arg will go */
  1201.       STACK_TMP(CDR(walker));
  1202.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase) /*mod*/,
  1203.                  ARG_1(stackbase) /* env */,CAR(walker)));
  1204.       UNSTACK_TMP(walker);
  1205.  
  1206.       if (walker == nil)
  1207.     {
  1208.       CallError(stacktop,
  1209.             "Generic function wants more args", gf, NONCONTINUABLE);
  1210.     }
  1211.     }
  1212.  
  1213.   if (extra)
  1214.     { 
  1215.       LispObject ptr;
  1216.  
  1217.       stacktop=argbase+argcount;
  1218.  
  1219.       if (walker!=nil)
  1220.     {
  1221.       STACK_TMP(CDR(walker));
  1222.       EUCALLSET_2(lastarg,Fn_cons,CAR(walker),nil);
  1223.       UNSTACK_TMP(walker);
  1224.       STACK_TMP(lastarg);
  1225.       ptr = lastarg;
  1226.       while(walker!=nil)
  1227.         {    
  1228.           LispObject xx;
  1229.           STACK_TMP(CDR(walker));
  1230.           STACK_TMP(ptr);
  1231.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)/*mod*/, ARG_1(stackbase)/*env*/, CAR(walker));
  1232.           xx = EUCALL_2(Fn_cons, xx, nil);
  1233.           UNSTACK_TMP(ptr);
  1234.           CDR(ptr)=xx;
  1235.           ptr = CDR(ptr);
  1236.           UNSTACK_TMP(walker);
  1237.         }
  1238.       UNSTACK_TMP(lastarg);
  1239.     }
  1240.       else
  1241.     lastarg=nil;
  1242.     }
  1243.   else
  1244.     {     
  1245.       if (CDR(walker)!=nil)
  1246.     CallError(stacktop,"Eval: Too many args to Generic-function",CDR(walker),
  1247.           NONCONTINUABLE);
  1248.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase) /*mod*/,ARG_1(stackbase)/*env*/,CAR(walker));
  1249.     }
  1250.   NARY_PUSH_ARG(lastarg);
  1251.   gf=ARG_2(stackbase);
  1252.   return(NARY_EUCALL_1(generic_apply,gf));
  1253.   END_NARY_EUCALL();
  1254. }
  1255. EUFUN_CLOSE
  1256.  
  1257. EUFUN_2(module_mv_apply_1,op, form)
  1258. {
  1259.   LispObject module_apply_args(LispObject *, int , LispObject );
  1260.   LispObject *walker=stackbase;
  1261.   int n=0;
  1262.  
  1263.   while (is_cons(form))
  1264.     {
  1265.       *walker=CAR(form);
  1266.       form=CDR(form);
  1267.       walker++;
  1268.       n++;
  1269.     }
  1270.  
  1271.   if (form!=nil)
  1272.     CallError(stackbase,"Improper list passed to mv_apply",nil,NONCONTINUABLE);
  1273.  
  1274.   return(module_apply_args(stackbase,n,op));
  1275.   
  1276. }
  1277. EUFUN_CLOSE
  1278.  
  1279. /* More restatement */
  1280. LispObject module_apply_args(LispObject *stackbase, int callargs, LispObject fn)
  1281. {
  1282.   void listify_args(LispObject *,int ,LispObject *);
  1283.   LispObject *stacktop=stackbase+callargs;
  1284.  
  1285.   if (is_i_function(fn) || is_i_macro(fn))
  1286.     {
  1287.       int nargs=fn->I_FUNCTION.argtype;
  1288.       LispObject env=(LispObject)fn->I_FUNCTION.env;
  1289.       LispObject args;
  1290.       LispObject *walker=stackbase;
  1291.       int extras;
  1292.       
  1293.       extras= (nargs<0);
  1294.       
  1295.       if (nargs==0 && callargs==0)
  1296.     RETURN_EUCALL(EUCALL_3(Sf_progn,
  1297.                    fn->I_FUNCTION.home,
  1298.                    env,
  1299.                    fn->I_FUNCTION.body));
  1300.  
  1301.       if ( (callargs!=nargs)
  1302.       && (!extras || (extras && callargs < -nargs-1)))
  1303.     CallError(stackbase,"apply: i-function called with wrong number of args",fn,NONCONTINUABLE);
  1304.       
  1305.       STACK_TMP(fn);    /* we stack it twice on the off chance */
  1306.       STACK_TMP(fn);    /* it is an nary function called with n-1 args */
  1307.       for (args=fn->I_FUNCTION.bvl;
  1308.        is_cons(args);
  1309.        )
  1310.     {
  1311.       STACK_TMP(CDR(args));
  1312.       env=allocate_env(stacktop,CAR(args),*walker,env);
  1313.       walker++;
  1314.       UNSTACK_TMP(args);
  1315.     }
  1316.       if (args!=nil)
  1317.     {
  1318.       STACK_TMP(env); STACK_TMP(args);
  1319.       if (callargs!=nargs)
  1320.         listify_args(walker,callargs+nargs+1,stacktop);
  1321.  
  1322.       UNSTACK_TMP(args); UNSTACK_TMP(env);
  1323.       env=allocate_env(stacktop,args,*walker,env);
  1324.     }
  1325.       UNSTACK_TMP(fn);
  1326. #if 0 /* Stack paranioa */
  1327.       if (!is_i_function(fn) && !is_i_macro(fn))
  1328.     system_lisp_exit(0);
  1329. #endif
  1330.       RETURN_EUCALL(EUCALL_3(Sf_progn,
  1331.                  fn->I_FUNCTION.home,
  1332.                  env,
  1333.                  fn->I_FUNCTION.body));
  1334.       
  1335.     }    
  1336.   
  1337.   if (is_c_function(fn) || is_c_macro(fn) 
  1338. #ifdef BCI      
  1339.       || is_b_function(fn) || is_b_macro(fn)
  1340. #endif
  1341.       )
  1342.     {
  1343. #ifdef BCI
  1344.       int nargs=
  1345.     ((is_c_function(fn)||is_c_macro(fn))
  1346.      ? fn->C_FUNCTION.argtype
  1347.      : intval(bytefunction_nargs(fn)));
  1348. #else
  1349.       int nargs = fn->C_FUNCTION.argtype;
  1350. #endif
  1351.       if (is_c_function(fn) && fn->C_FUNCTION.env!=NULL)
  1352.     {    /* Whups --- the env needs to be inserted */
  1353.       int i;
  1354.       
  1355.       for (i=callargs; i>=0; i--)
  1356.         stackbase[i+1]=stackbase[i];
  1357.  
  1358.       stackbase[0]=(LispObject)fn->C_FUNCTION.env;
  1359.     }
  1360.       if (callargs!=nargs)
  1361.     {
  1362.       if (nargs<0 && callargs>= -nargs-1)
  1363.         {    
  1364.           int act= -nargs-1;
  1365.  
  1366.           STACK_TMP(fn); /* could be anything --- just to stop the */
  1367.           STACK_TMP(fn); /* value being blatted */
  1368.           listify_args(stackbase+act,callargs-act,stacktop);
  1369.           UNSTACK_TMP(fn);
  1370.         }
  1371.       else
  1372.         CallError(stacktop,"C function called with wrong number of args",fn,NONCONTINUABLE);
  1373.     }
  1374. #ifdef BCI
  1375.       if (is_c_function(fn) || is_c_macro(fn))
  1376.     return((fn->C_FUNCTION.func)(stackbase));
  1377.       else
  1378.     return(apply_nary_bytefunction(stackbase,
  1379.                        nargs>0 ? nargs : -nargs,
  1380.                        fn));
  1381. #else
  1382.       return((fn->C_FUNCTION.func)(stackbase));
  1383. #endif      
  1384.     }            
  1385.  
  1386.   if (is_generic(fn))
  1387.     {    
  1388.       int nargs=intval(generic_argtype(fn));
  1389.       
  1390.       if (nargs!=callargs)
  1391.     CallError(stacktop,"Generic called with wrong number of args",fn,NONCONTINUABLE);
  1392.  
  1393.       return(generic_apply(stackbase,fn));
  1394.     }
  1395.  
  1396.   if (is_continue(fn))
  1397.     {
  1398.       if (callargs==0)
  1399.     {
  1400.       call_continuation(stackbase,fn,nil);
  1401.       return nil; 
  1402.     }
  1403.  
  1404.       if (callargs==1)
  1405.     {
  1406.       call_continuation(stackbase,fn,*stackbase);
  1407.     }
  1408.       CallError(stackbase,"apply: continuation: too many args",fn,NONCONTINUABLE);
  1409.       /* nope */
  1410.       return nil;
  1411.     }
  1412.  
  1413.   
  1414.   CallError(stacktop, "module multiple-apply: invalid op",fn,
  1415.         NONCONTINUABLE);
  1416.   return nil;
  1417. }
  1418.  
  1419. /* Should be a macro */
  1420. void listify_args(LispObject *start,int n,LispObject *stacktop)
  1421. {
  1422.   int i;
  1423.   LispObject lst;
  1424.  
  1425.   if (n==0)
  1426.     {
  1427.       *start=nil;
  1428.       return;
  1429.     }
  1430.   
  1431.   lst=allocate_n_conses(stacktop,n);
  1432.   CAR(lst)= *start;
  1433.   *start = lst;
  1434.  
  1435.   start++;
  1436.   lst=CDR(lst);
  1437.   for (i=1; i<n; i++)
  1438.     {
  1439.       CAR(lst) = *start;
  1440.       lst=CDR(lst);
  1441.       start++;
  1442.     }
  1443. }
  1444. #define SYM_REF_DBG(x) /* x;fflush(stderr); */
  1445.  
  1446. LispObject symbol_ref(LispObject *stacktop,
  1447.               LispObject mod,LispObject env,LispObject sym)
  1448. {
  1449.   Env walker;
  1450.   LispObject spec;
  1451.  
  1452. SYM_REF_DBG(fprintf(stderr,"symol_ref with sym '%s'\n",stringof(sym->symbol.pname)));
  1453.  
  1454.   /* parameter environment */
  1455.  
  1456.   walker = &(env->ENV);
  1457.  
  1458. SYM_REF_DBG(fprintf(stderr,"symol_ref env search\n"));
  1459.  
  1460.   while (walker != NULL) {
  1461.     if (walker->variable == sym) 
  1462.       return(walker->value);
  1463.     else
  1464.       walker = walker->next;
  1465.   }
  1466.  
  1467.   /* self evaluating symbols */
  1468.  
  1469.   if (sym == sym_nil) return(nil);
  1470.   if (sym == lisptrue) return(lisptrue);
  1471.   
  1472.   /* Check caches */
  1473.   if (sym->SYMBOL.lmodule == mod) return(sym->SYMBOL.lvalue);
  1474.  
  1475.   /* language constructs and key words */
  1476.  
  1477.   spec=EUCALL_2(Fn_tref,special_table,sym);
  1478.  
  1479.   if (spec != nil) 
  1480.     {
  1481.       sym->SYMBOL.lmodule=mod;
  1482.       sym->SYMBOL.lvalue=spec;
  1483.       return spec;    
  1484.     }
  1485.   
  1486.   /* module reference */
  1487.  
  1488.   return(EUCALL_2(Fn_module_value,mod,sym));
  1489. }
  1490.  
  1491.  
  1492. LispObject module_set_new(LispObject *stacktop,LispObject mod,LispObject sym,LispObject val)
  1493. {
  1494.   return(EUCALL_4(module_set_new_aux,mod,sym,val,lisptrue));
  1495. }
  1496.  
  1497. LispObject module_set_new_constant(LispObject *stacktop,LispObject mod,
  1498.                    LispObject sym,LispObject val)
  1499. {
  1500.   return(EUCALL_4(module_set_new_aux,mod,sym,val,nil));
  1501. }
  1502.  
  1503.  
  1504. EUFUN_2(Fn_module_value, mod, sym)
  1505. {
  1506.   LispObject bind;
  1507.   
  1508.   bind=GET_BINDING(mod,sym);
  1509.  
  1510.   if (bind==nil)
  1511.     {
  1512.       LispObject xx;
  1513.       xx=EUCALL_2(Fn_cons,mod->MODULE.name,sym);
  1514.       CallError(stacktop,"module value: No such binding",xx,NONCONTINUABLE);
  1515.     }
  1516.   if (is_cons(bind))
  1517.     { /* Good value */
  1518.       LispObject val;
  1519.  
  1520.       if (is_i_module(BINDING_HOME(bind)))
  1521.     {
  1522.       val = BINDING_VALUE(bind);
  1523.       sym->SYMBOL.lmodule=mod;
  1524.       sym->SYMBOL.lvalue=val;
  1525.       return val;
  1526.     }
  1527.       if (is_c_module(BINDING_HOME(bind)))
  1528.     {
  1529.       val=vref((BINDING_HOME(bind)->C_MODULE.values),intval(BINDING_VALUE(bind)));
  1530.       sym->SYMBOL.lmodule=mod;
  1531.       sym->SYMBOL.lvalue=val;
  1532.       return val;
  1533.     }
  1534.       else 
  1535.     CallError(stacktop,"Unexpected module type",bind,NONCONTINUABLE);    
  1536.     }
  1537.  
  1538.   CallError(stacktop,"Unexpected value of binding",bind,NONCONTINUABLE);
  1539.   return nil;
  1540. }
  1541. EUFUN_CLOSE
  1542.  
  1543. EUFUN_3(module_set,mod, sym, val)
  1544. {
  1545.   LispObject bind;
  1546.  
  1547.   
  1548.   if (is_c_module(mod))
  1549.     CallError(stacktop,"module set: can't set in compiled module",sym,NONCONTINUABLE);
  1550.  
  1551.   if(reserved_symbol_p(sym))
  1552.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1553.  
  1554.   bind=GET_BINDING(mod,sym);
  1555.  
  1556.   if (bind==nil)
  1557.     {    /* Be kind and add it anyhow */
  1558.       sym->SYMBOL.lmodule=nil;
  1559.       sym->SYMBOL.lvalue=nil;
  1560.       ADD_BINDING(ARG_0(stackbase)/* mod*/, ARG_1(stackbase)/*sym*/,
  1561.           ARG_2(stackbase)/*val*/,lisptrue);
  1562.       return ARG_2(stackbase);
  1563.     }
  1564.   
  1565.   if (BINDING_MUTABLE(bind)==lisptrue)
  1566.     {
  1567.       sym->SYMBOL.lmodule=nil;
  1568.       sym->SYMBOL.lvalue=nil;
  1569.       BINDING_VALUE(bind)=val;
  1570.       return val;
  1571.     }
  1572.   else
  1573.     {
  1574.       sym->SYMBOL.lmodule=nil;
  1575.       sym->SYMBOL.lvalue=nil;
  1576.       
  1577.       fprintf(StdErr->STREAM.handle,"*** Setting immutable binding\n");
  1578.       BINDING_VALUE(bind)=val;
  1579.       return val;
  1580.     }
  1581.   
  1582.   CallError(stacktop,"module set: How the hell did I get here",sym,NONCONTINUABLE);
  1583.   return nil;
  1584. }
  1585. EUFUN_CLOSE
  1586.  
  1587. static EUFUN_4(module_set_new_aux,mod,sym,val,mutability)
  1588. {
  1589.   LispObject bind;
  1590.  
  1591.   if (!is_i_module(mod))
  1592.     CallError(stacktop,"Module set new: tried to set in compiled module",sym,NONCONTINUABLE);
  1593.  
  1594.   if(reserved_symbol_p(sym))
  1595.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1596.  
  1597.   bind=GET_BINDING(mod,sym);
  1598.   
  1599.   if (bind==nil)
  1600.     { /* Its a newie */
  1601.       ADD_BINDING(ARG_0(stackbase),ARG_1(stackbase),ARG_2(stackbase),ARG_3(stackbase));
  1602.       sym->SYMBOL.lmodule=nil;
  1603.       sym->SYMBOL.lvalue=nil;
  1604.       return ARG_1(stackbase);
  1605.     }
  1606.   else
  1607.     {
  1608.       if (BINDING_HOME(bind)==mod)
  1609.     {
  1610.       sym->SYMBOL.lmodule=nil;
  1611.       sym->SYMBOL.lvalue=nil;
  1612.       BINDING_VALUE(bind)=val;
  1613.       BINDING_MUTABLE(bind)=mutability;
  1614.       return sym;
  1615.     }
  1616.       else
  1617.     CallError(stacktop,"Module set new: tried to set over imported binding",sym,NONCONTINUABLE);
  1618.     }
  1619.   /* NOT ever */
  1620.   return nil; 
  1621. }
  1622. EUFUN_CLOSE
  1623.  
  1624. EUFUN_4(register_module_import, mod, name, inmod, inname)
  1625. {
  1626.   LispObject bind, localbind;
  1627.   LispObject xx;
  1628.   if (is_c_module(mod))
  1629.     CallError(stacktop, "register import: can't import into compiled module",
  1630.           mod,NONCONTINUABLE);
  1631.  
  1632.   /* ok, but is it exported anyhow ? */
  1633.  
  1634.   EUCALLSET_2(xx, Fn_memq, inname, module_exports(inmod));
  1635.   if (xx == nil)
  1636.     CallError(stacktop, "register import: name not exported",inname,
  1637.           NONCONTINUABLE);
  1638.   
  1639.   /* Into canonical form */
  1640.  
  1641.   bind=GET_BINDING(inmod,inname);
  1642.   
  1643.   if (bind==nil)
  1644.     {
  1645.       xx=EUCALL_2(Fn_cons,inmod->C_MODULE.name,inname);
  1646.       CallError(stacktop,"non-existent binding exported", xx,NONCONTINUABLE);
  1647.     }
  1648.   /* See if we have something of the same name */
  1649.   localbind=GET_BINDING(mod,name);
  1650.  
  1651.   if (localbind==nil)
  1652.     { /* add it */
  1653.       IMPORT_BINDING(mod,name,bind);
  1654.       return nil;
  1655.     }
  1656.   else 
  1657.     {
  1658.       if (bind==localbind) /* done this before */
  1659.     return nil;
  1660.       else 
  1661.     {
  1662.       xx=EUCALL_2(Fn_cons, inmod->C_MODULE.name,name);
  1663.       CallError(stacktop,"register import: binding exists locally",xx,NONCONTINUABLE);
  1664.     }
  1665.     }
  1666.  
  1667.   CallError(stacktop,"Register import: Yeouch. not here",nil,NONCONTINUABLE);
  1668.  
  1669.   return nil;
  1670. }
  1671. EUFUN_CLOSE
  1672.  
  1673. int module_binding_exists_p(LispObject *stacktop,LispObject mod,LispObject name)
  1674. {
  1675.   LispObject bind;
  1676.   
  1677.   bind=GET_BINDING(mod,name);
  1678.   
  1679.   return (bind!=nil);
  1680. }    
  1681.  
  1682.  
  1683. /* *************************************************************** */
  1684. /* Initialisation of this section                                  */
  1685. /* *************************************************************** */
  1686.  
  1687. void initialise_modules(LispObject *stacktop)
  1688. {
  1689.   extern MODULE *current_open_module;
  1690.  
  1691.   sym_include_forms = get_symbol(stacktop,"include-forms");
  1692.   add_root(&sym_include_forms);
  1693.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_interactive_module,NULL);
  1694.   ADD_SYSTEM_GLOBAL_ROOT(current_interactive_module);
  1695.   global_module_table = (LispObject) allocate_table(stacktop,Fn_eq);
  1696.   add_root(&global_module_table);
  1697.   add_root((LispObject*)¤t_open_module);
  1698.   backtrace_handle = get_symbol(stacktop,"****backtrace-handle****");
  1699.   add_root(&backtrace_handle);
  1700.   sym_only   = get_symbol(stacktop,"only");
  1701.   add_root(&sym_only);
  1702.   sym_except = get_symbol(stacktop,"except");
  1703.   add_root(&sym_except);
  1704. }
  1705.  
  1706.